begin "dvialf" comment convert DVI files to files that go to the Alphatype
			THIS IS A PRELIMINARY, NON-OPTIMAL VERSION by drf ;
define # = "comment ";
define crlf = "'15&'12";
require "{}{}" delimiters;
define thru = { step 1 until };
define L1={ ((((4)*16+0)*16+2)*16+0) };
define R1={ ((((7)*16+3)*16+0)*16+0) };
define L2={ ((((8)*16+5)*16+0)*16+14) };
define R2={ ((((11)*16+12)*16+1)*16+8) };
define compensation={ 1421 };
comment define LCOG={ (2048) };
comment define RCOG={ (2048+900) };
define A={ 1365 }; define B={2047};
define PSH={20}; # stack size;

define	NOP={128}, BOP={129}, EOP={130}, PST={131}, 
	DVIPUSH={132}, DVIPOP={133},
	VERTRULE={134}, HORZRULE={135}, HORZCHAR={136}, DVIFONT={137},
	W4={138}, W3={139}, W2={140}, W0={141},
	X4={142}, X3={143}, X2={144}, X0={145},
	Y4={146}, Y3={147}, Y2={148}, Y0={149},
	Z4={150}, Z3={151}, Z2={152}, Z0={153},
	FONTNUM={154}; # to 217;

external integer !skip!;
integer dbug,tdbug,ebug;

integer dvi,ant,alf,dviw,dvibytecnt;
string filename,s;

integer w,h,i,j,k,v;
integer array accs[0:'17];

integer c,addr,dx;
integer lmarg,tmarg,bmarg,pagelimit,ask;
integer mark,nv,id;
integer lastw,lastx,lasty,lastz;
integer array pshwamt[0:PSH], pshxamt[0:PSH], pshyamt[0:PSH], pshzamt[0:PSH],
	pshx[0:PSH], pshy[0:PSH]; integer stkptr;
integer x,y;
integer pagecycle,cyclecnt; integer array xcycle[0:9], ycycle[0:9];
integer lcog,rcog;

preload!with [65] -1;
integer array fontptr[0:64];
string array fontname[0:64];
integer oword, wordcnt;
integer postambleptr;
integer pagecnt,pageno;
integer fontno,maxpageheight,maxpagewidth,lastpageptr;
integer memptr;
integer array ano[0:64,0:127];
integer array yx[0:8000]; integer array fcp[0:8000]; integer yxfcptr;
integer array mem[0:60000]; # holds font files;

procedure error(string err); begin integer i;
	print(crlf,crlf,err,crlf);
	start!code
		movei 0,'123456;
		movei 1,0;
		haltf;
		end;
	end;

procedure push; begin
	if stkptr>PSH then error("STACK OVERFLOW-YOU LOSE!");
	pshx[stkptr]←x; pshy[stkptr]←y;
	pshwamt[stkptr]←lastw;
	pshxamt[stkptr]←lastx;
	pshyamt[stkptr]←lasty;
	pshzamt[stkptr]←lastz;
	stkptr←stkptr+1;
	end;

procedure pop; begin
	stkptr←stkptr-1;
	if stkptr<0 then error("STACK UNDERFLOW BUG!");
	x←pshx[stkptr]; y←pshy[stkptr];
	lastw←pshwamt[stkptr];
	lastx←pshxamt[stkptr];
	lasty←pshyamt[stkptr];
	lastz←pshzamt[stkptr];
	end;

integer procedure getb; begin integer r;
	r←(dviw lsh -24) land '377;
	dviw←dviw lsh 8;
	dvibytecnt←dvibytecnt+1;
	if (dvibytecnt land 3)=0 then dviw←wordin(dvi); 
	return(r);
	end;

procedure gotobyte(integer n); begin integer w,r;
	w←n div 4; r←n-(w*4);
	swdptr(dvi,w);
	dviw←wordin(dvi) lsh (8*r);;
	dvibytecnt←n;
	end;

integer procedure twobytes; begin integer n;
	n←(getb lsh 8) lor getb ;
	return((n lsh 20) ash -20);
	end;

integer procedure threebytes; begin integer n;
	n←(((getb lsh 8) lor getb) lsh 8) lor getb ;
	return((n lsh 12) ash -12);
	end;

integer procedure fourbytes; begin integer n;
	n←(((((getb lsh 8) lor getb) lsh 8) lor getb) lsh 8) lor getb;
	return((n lsh 4) ash -4);
	end;

procedure o(integer n); begin
	oword←(oword lsh 9) lor '400 lor (n land '377);
	if (oword<0) then begin
		wordout(alf,oword rot wordcnt);
		wordcnt←(wordcnt+1) mod 17;
		oword←0;
		end;
if dbug then print(" out '",cvos(n land '377),crlf);
	end;

define oo(n)={ begin o(n); o(n lsh -8); end };

integer procedure du(integer n); return( (n/(2↑16)) * (32000/9) / 72.27);
integer procedure fu(integer n); return( (n/(2↑16)) * (8000/5)  / 72.27);

procedure setchar(integer c,flag); begin 
	integer cptr,sptr,parts,part,width;
	cptr←fontptr[fontno]+c;
	parts←mem[cptr] lsh -18;
	sptr←fontptr[fontno] + (mem[cptr] land '777777);
	width←mem[3+sptr] lsh -2;
	for part←0 step 1 until parts-1 do begin
		integer netx,nety,xoffset,yoffset,bytetimes;
		bytetimes←mem[sptr+2] lsh 18;
		if bytetimes=0 then continue;
		xoffset←mem[sptr] ash -18;
		yoffset←(mem[sptr] lsh 18) ash -18;
		yxfcptr←yxfcptr+1;
		netx←du(x)-xoffset+xcycle[pagecycle];
		nety←fu(y)-yoffset+ycycle[pagecycle];
IF EBUG then PRINT("char "&c,if part then "."&cvos(part) else ""," at ",
	netx," du = ",du(x),"-",xoffset,"+",xcycle[pagecycle],", ",
	nety," fu = ",fu(y),"-",yoffset,"+",ycycle[pagecycle],crlf);
IF XOFFSET NEQ 0 OR NETX<0 OR NETX>55487 OR NETY<0 OR NETY>29190 THEN 
	PRINT("LUMPH ",INTTY);
		yx[yxfcptr]←(nety lsh 18) lor netx;
		fcp[yxfcptr]←(fontno lsh 14) lor
				((c LAND '177) lsh 7) lor part;
		sptr←sptr+4;
		end;
	if flag then x←x+width;
	end;

procedure touchfont(integer fontno); begin string s;
	if fontptr[fontno]>-1 then return;
	s←fontname[fontno]; 
PRINT(crlf,"loading ",s," at ",memptr);
	ant←openfile(s&".ANT","ROE");
	if !skip! then begin
		while (lop(s) neq ">") do begin end;
		ant←openfile(s&".ANT","ROE");
		end;
	if !skip! then error(s&" -- FONT MISSING!");
	fontptr[fontno]←memptr;
	arryin(ant,mem[memptr],99999);
	memptr←memptr+ (!skip! land '777777); 
PRINT(" used ",!skip! land '777777,crlf);
	cfile(ant);
	end;

procedure chngmult(integer newa,newb); begin
if ebug then print("Changing multipliers to A=",newa,", B=",newb,crlf);
	o(1); oo(newa); oo(newb);
	end;

procedure dispm(string s); begin integer i,l;
if ebug then print("Display: ",s,crlf);
	l←length(s);
	o(0); o(0); o(l); for i←1 thru l do o(lop(s)); end;

procedure bpage(integer g,y,p); begin
if ebug then print("Begin page g=",g," y=",y," p=",p,crlf);
	o(0); o(1); oo(g); oo(y); oo(p); end;

procedure adjust(integer d); begin
if ebug then print("Adjust cogs ",d,crlf);
	o(0); o(0); o(0); oo(d); end;

procedure set(integer c,x,g,h); begin 
if ebug then print("Set ",c," at ",x," g=",g," h=",h,crlf);
	o(c); oo(x); o(g); o(h); end;

procedure eoln(integer g); begin
if ebug then print("Eoln at ",g,crlf);
	o(0); o(2); oo(g); end;

procedure feed(integer y); begin
if ebug then print("Feed ",y,crlf);
	o(2); o(2); oo(y); end;

procedure eofilm; begin
print("End film",crlf);
dispm("EOFILM...");
	o(2); o(1); end;

procedure chngbrit(integer newbrit); begin 
if ebug then print("Change brightness to ",newbrit,crlf);
	o(2); o(0); oo(newbrit); end;

integer procedure loadalf(integer fromhere); begin
	integer m,actr,f,c,sgptr,parts,i,j,k,bptr,w,x,bytes;
	arrclr(ano);
	m←L1;
	actr←3;
	bpage(LCOG,(yx[fromhere] lsh -18),pageno);
	for i←fromhere thru yxfcptr do begin "loadupmem"
		f← (fcp[i] lsh -14) land '77;
		c← (fcp[i] lsh -7) land '177;
		if ano[f,c]>0 then continue;
		ano[f,c]←actr;
		sgptr←(mem[fontptr[f]+c] land '777777) + fontptr[f];
		parts←mem[fontptr[f]+c] lsh -18;
		for j← 1 thru parts do begin
			bptr←(mem[sgptr+2+4*(j-1)] land '777777)+fontptr[f];
			bytes←mem[bptr];
			if (m<R1) and (m+bytes+4 geq R1) then m←L2;
			if (m+bytes+4 geq R2) then done "loadupmem";
comment dispm("D"&CVS(actr));
if ebug then print("loading ",f," '",cvos(c)," ",j," as ",actr,
	" at ",m," ('",cvos(m),") for ",bytes,crlf);
			o(0); o(actr); oo(m); oo(bytes);
			actr←actr+1;
			m←m+bytes+4;
			x←mem[fontptr[f]+128];
			tdbug←dbug; dbug←0;
			for k←0 thru bytes-1 do begin
				if (k land 3)=0 then begin
					bptr←bptr+1;
					x←x*367965721+256854611;
					w←mem[bptr] xor (x lsh -4);
					end;
				o(w lsh -24);
				w←w lsh 8;
				end;
			dbug←tdbug;
			end;
		end; 
DISPM("E");
	return(i-1);
	end;


procedure outalf(integer fromhere, tothere); begin 
	integer i,rl,y,newy,alfy,cnt,lastcnt,newg,newh,ritebit,leftbit,
			g,h,oldh,t,x,sgptr,f,c,p,bytetimes,newbytetimes,
			dropit,firstdropped,dg,dh,d;
	y←alfy←yx[fromhere] lsh -18;
	rl←1;
	i←fromhere;
	cnt←0;
	while i leq tothere do begin
		rl←1-rl;
		adjust(rl*compensation/32);
		g←h←oldh←LCOG+rl*(compensation/32);
		lastcnt←cnt;
		cnt←0;
		bytetimes←0;
		firstdropped←-1;
comment uncomment following line for one-way typesetting, else 2-way;
comment IF NOT RL THEN; 
		while true do begin
			while fcp[i]<0 and i leq tothere do i←i+1;
			if i>tothere then done;
			if (yx[i] lsh -18)>y then done;
			if lastcnt+cnt>197 then done;
			f← (fcp[i] lsh -14) land '77;
			c← (fcp[i] lsh -7) land '177;
			p← fcp[i] land '177;
			sgptr←(mem[fontptr[f]+c] land '777777)+fontptr[f]+4*p;
			newbytetimes← mem[sgptr+2] lsh -18;
			x←rl*compensation+ (yx[i] land '777777);
			leftbit←mem[sgptr+1] lsh -18;
			ritebit←mem[sgptr+1] land '777777;
			newg←((((leftbit*A) lsh -11)-((360*A) lsh -11)+x)
					lsh -5) + 2048;
			newh←((((ritebit*A) lsh -11)-((360*A) lsh -11)+x)
					lsh -5) + 2048;
			dropit←0;
			if (g geq newg) then dropit←1;
			if (h geq newh) then dropit←dropit+2;
			if (newg leq oldh) then dropit←dropit+4;
			if ((newg leq h) and (newbytetimes+bytetimes>1021))
				then dropit←dropit+8;
			if dropit then begin 
					if firstdropped=-1 then firstdropped←i;
if ebug then print(" dropped f",f," "&c&"'",cvos(c)," p",p," cause ",dropit, 
  " g",g," newg",newg," h",h," newh",newh," x",x); 
					i←i+1;
					continue;
					end;
			dg←newg-g; dh←newh-h;
if ebug then print("put f",f," "&c&"'",cvos(c)," p",p," x",x," lbit",leftbit,
 " rbit",ritebit," ng",newg," dg",dg," nh",newh," dh",dh," bt",bytetimes,crlf);
IF DG<0 OR DH<0 THEN PRINT("WHOOPS!!",INTTY);
			if dg>255 or dh>255 then begin
				d←dg min dh;
				adjust(d);
				g←g+d; h←h+d;
				cnt←cnt+1;
				end;
			set(ano[f,c]+p,x,newg-g,newh-h);
			oldh←h; g←newg; h←newh; bytetimes←newbytetimes;
			cnt←cnt+1;
			fcp[i]←-1;
			i←i+1;
			end;

		if rcog<h then print(intty,"OH NO",intty);
comment		adjust(((RCOG-h)*32+compensation)/32);
		adjust(RCOG-h);

		if firstdropped>0 then i←firstdropped
		else while fcp[i]<0 and i leq tothere do i←i+1;
		if i<=tothere then begin
			newy←yx[i] lsh -18;
			if newy>alfy+1 then begin
				feed(newy-alfy);
				alfy←newy;
				end;
			y←newy;
			end;

		if rl then eoln(LCOG)
		else eoln(RCOG+compensation/32); comment hack;

		end;
	end;


procedure sort; begin "sort" integer i,delta;
	delta←1; while 9*delta+3<yxfcptr do delta←3*delta+1;
	while delta>0 do begin
		for i←delta step 1 until yxfcptr do
			if yx[i-delta]>yx[i] then begin integer j,k,t1,t2;
				j←i-delta; 
				t1←yx[i]; t2←fcp[i];
				k←i;
				do begin
					yx[k]←yx[j]; fcp[k]←fcp[j];
					k←j; j←j-delta;
					end until j<0 or yx[j] leq t1;
				yx[k]←t1; fcp[k]←t2;
				end;
		delta←delta div 3;
		end;
	end "sort";

comment main program ;
dbug←0; ebug←0;
oword←wordcnt←0;
arrclr(fontptr,-1);

print(".DVI file: ");
filename←intty;
s←filename&".ALF";
filename←filename&".DVI";
print("Input from ",filename,crlf);
dvi←openfile(filename,"ROE");
if !skip! then error("Couldn't open "&filename);
alf←openfile(s,"WE");
if !skip! then error("Couldn't open "&s);


swdptr(dvi,-1);
postambleptr←(rwdptr(dvi))*4-3;
gotobyte(postambleptr←postambleptr-1);
if getb neq 223 then error("No Postamble -- bad DVI file.");
while true do begin integer t;
	gotobyte(postambleptr←postambleptr-1);
	if (t←getb) = 0 then done;
	if t neq 223 then error("Bad DVI file format");
	end;
gotobyte(postambleptr←postambleptr-4);
postambleptr←fourbytes;
# PRINT("POSTAMBLE AT BYTE ",POSTAMBLEPTR,".  ");
gotobyte(postambleptr);

if getb neq PST then error("Bad DVI file format");
lastpageptr←fourbytes;
maxpageheight←fu(fourbytes);
maxpagewidth←du(fourbytes);

while true do begin "get font names"
	if (id←fourbytes) = -1 then done;
	fontno←fourbytes;
	s←""; mark←getb; while (nv←getb) neq mark do s←s&nv;
	fontname[fontno]←s;
	end "get font names";

cyclecnt←6; pagecycle←0;

xcycle[0]←1024;		xcycle[1]←19168-320;	xcycle[2]←37312-640;
ycycle[0]←ycycle[1]←ycycle[2]←1000-1000;

xcycle[3]←1024;		xcycle[4]←19168-320;	xcycle[5]←37312-640;
ycycle[3]←ycycle[4]←ycycle[5]←14752-2000;

pagelimit←6;
ASK←1; 
if ask then begin
	print("Starting at page (default=first) ");
	s←intty;
	if s then begin
		i←cvd(s);
		while true do begin
			gotobyte(lastpageptr);
			if getb neq BOP then error("Bad beginning of page");
			if fourbytes=i then done;
			if (lastpageptr←fourbytes)=-1 then 
				error("No such page");
			end;
		gotobyte(lastpageptr);
		end
	else gotobyte(0);
	print("Number of pages (default=6) ");
	s←intty;
	if s then pagelimit←cvd(s);
	end
else gotobyte(0);

chngbrit(2700);
chngmult(A,B);

while true do begin "do a command";
	while (v←getb) geq FONTNUM do touchfont(fontno←v-FONTNUM);
	case v of begin "case stmt"
	[NOP] begin # PRINT("N"); end;
	[BOP] begin "BOP" yxfcptr←-1; 
		x←y←24*(1 lsh 16); # left and top margin of 24 points;
		print(" [",pageno←FOURBYTES); FOURBYTES; 
		pagecnt←pagecnt+1;
		end "BOP";
	[EOP] begin "EOP" integer fromhere, tothere;
		sort; print("]");
		lcog←2048+(xcycle[pagecycle] div 32);
		rcog←lcog+750;
if ebug then PRINT("LCOG ",lcog," RCOG ",rcog,crlf);
		fromhere←0; tothere←-1;
		while (tothere<yxfcptr) do begin
			tothere←loadalf(fromhere);
comment PRINT(" FROM ",FROMHERE," TO ",TOTHERE,CRLF);
			outalf(fromhere,tothere);
			fromhere←tothere+1;
			end;
		if pagecnt>=pagelimit then done;
		pagecycle←pagecycle+1;
		if pagecycle=cyclecnt then begin eofilm; pagecycle←0; end;
		end "EOP";
	[HORZRULE]
	[VERTRULE] begin "RULE" integer height,width,yoffset,xoffset,h,w;
		height←fourbytes; width←fourbytes; h←fu(height); w←du(width);
		comment yxfcptr←yxfcptr+1;
		comment yx[yxfcptr]← (fu(y) lsh 18) lor du(x);
		comment fcp[yxfcptr]←(3 lsh 34);
		if v=VERTRULE then x←x+width; end "RULE";
	[HORZCHAR] begin c←getb; setchar(c,0); end;
	[DVIFONT] touchfont(fontno←fourbytes);
	[DVIPUSH] push;
	[DVIPOP] pop;
	[W0] x←x+lastw;
	[W2] begin lastw←twobytes; x←x+lastw; end;
	[W3] begin lastw←threebytes; x←x+lastw; end;
	[W4] begin lastw←fourbytes; x←x+lastw; end;
	[X0] x←x+lastx;
	[X2] begin lastx←twobytes; x←x+lastx; end;
	[X3] begin lastx←threebytes; x←x+lastx; end;
	[X4] begin lastx←fourbytes; x←x+lastx; end;
	[Y0] y←y+lasty;
	[Y2] begin lasty←twobytes; y←y+lasty; end;
	[Y3] begin lasty←threebytes; y←y+lasty; end;
	[Y4] begin lasty←fourbytes; y←y+lasty; end;
	[Z0] y←y+lastz;
	[Z2] begin lastz←twobytes; y←y+lastz; end;
	[Z3] begin lastz←threebytes; y←y+lastz; end;
	[Z4] begin lastz←fourbytes; y←y+lastz; end;
	[PST] done;
	else setchar(v,1)
	end "case stmt";

	end "do a command";
eofilm;
print(crlf);
wordout(alf,oword rot wordcnt); # force out remaining buffer;
cfile(dvi); cfile(alf);
start!code
	comment haltf;
	end;
end "dvialf";